home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / encorsrc.lha / encore_sources / link / test.t < prev    next >
Text File  |  1988-05-02  |  2KB  |  54 lines
  1. (herald test (env tsys))
  2.  
  3. (define-structure-type lstate   ;linker state
  4.     pure            
  5.     impure          
  6.     foreign-reloc   
  7.     foreign                     
  8.     symbols                        
  9.     symbol-count
  10.     text-reloc   ;List of relocation items
  11.     data-reloc
  12.     pure-size
  13.     reloc 
  14.     null
  15.     )
  16.  
  17. (define-structure-type +area         ;A.k.a. "heap"
  18.   frontier      ;Address of next available cell
  19.   objects       ;List of objects allocated
  20.   )
  21.  
  22. (define (vgc-extend obj ptrs size)
  23.   (let* ((heap (lstate-impure *lstate*))
  24.          (addr (+area-frontier heap))
  25.          (desc 
  26.            (if (fx= ptrs size)
  27.                (object nil
  28.                  ((heap-stored self) (lstate-impure *lstate*))
  29.                  ((heap-offset self) addr)
  30.                  ((write-descriptor self stream)
  31.                   (write-data stream (fx+ addr tag/extend)))
  32.                  ((write-store self stream)
  33.                   (do ((i -1 (fx+ i 1)))
  34.                       ((fx= i ptrs) t)
  35.                     (write-slot (extend-elt obj i) stream))))
  36.                (object nil
  37.                  ((heap-stored self) (lstate-impure *lstate*))
  38.                  ((heap-offset self) addr)
  39.                  ((write-descriptor self stream)
  40.                   (write-data stream (fx+ addr tag/extend)))
  41.                  ((write-store self stream)
  42.                   (do ((i -1 (fx+ i 1)))
  43.                       ((fx= i ptrs)
  44.                        (do ((i i (fx+ i 1)))
  45.                            ((fx= i size) t)
  46.                          (write-scratch stream obj i)))
  47.                     (write-slot (extend-elt obj i) stream)))))))
  48.       (set (+area-frontier heap) (fx+ addr (fx+ (fx* CELL size) CELL)))
  49.       (push (+area-objects heap) desc)
  50.       (set-lp-table-entry (lstate-reloc *lstate*) obj desc)
  51.       (do ((i -1 (fx+ i 1))
  52.            (a addr (fx+ a CELL)))
  53.           ((fx= i ptrs) desc)
  54.         (generate-slot-relocation (extend-elt obj i) a))))